perm filename CLFZ.F4[1,MUS] blob sn#075938 filedate 1973-12-04 generic text, type T, neo UTF8
00100		SUBROUTINE CLEFS
00200		IMPLICIT INTEGER(A-Q,S-Z)
00300		DIMENSION JCLEF(10),MCLEF(400),RCMIN(4)
00400		REAL DIS,PWDS,DISX,CENTR,POS,STF
00500		COMMON /STF/RSTFAC(8),RSTJC
00600		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
00700		COMMON/PLTR/PLT,RHT,DIS
00900	      DATA RCMIN/3.3,10.5,7.0,10.5/,JFX/-1/
01000		EQUIVALENCE (JD,JQ(2)),(RJD,RJQ(2)),(JE,JQ(3))
01100	     1 ,(RJF,RJQ(4)),(RJE,RJQ(3)),(JH,JQ(6)),(RJG,RJQ(5))
01200		NM='CLFX'
01300		JE=MOD(JE,100)
01350		IF(JE.EQ.0)JE=1
01400		IF(JA.EQ.3)GO TO 2
01500		NM='DRAW1'
01600		IF(JE.GE.10)NM='DRAW2'
01700	C  9 X 2 OBJECTS AVAILABLE.  ALSO 50 WDS LEFT IN CLFX
01800	2	JEZ=MOD(JE,10)
01900		IF(NM.EQ.JNM)GO TO 30
02000	C  JUMP IF ALREADY IN CORE
02100		JNM=NM
02200		CALL RDDATA(NM,JCLEF,MCLEF)
02300	CC30	CENTR=POS+2*RSTJC+RJD*RSTJC*7
02350	30	CALL CENTER(CENTR)
02400	C   CHECK THE ABOVE  -- FOR P5 HEIGHT CHANGE *********************
02500		IF(RJF.EQ.0)RJF=1
02600		IF(RJG.EQ.0)RJG=1
02700	C  RJF IS SIZE FACTOR
02800		IF(JE.GT.4.OR.JA.NE.3)GO TO 811
02900		IF(RJE.LT.100)GO TO 812
03000		RSTJC=.8*RSTJC
03100		CENTR=CENTR+RCMIN(JEZ)*RSTJC
03200	C  TO SET HGT. OF MINI CLEFS
03300	812	IF(JEZ.NE.4)GO TO 811
03400		CENTR=CENTR+RSTJC*14
03500		JEZ=3
03600	C   ABOVE IS NOW AT TOP
03700	811	L=JCLEF(JEZ)
03800		CALL JDRAW(MCLEF(L),RJB,CENTR,RSTJC,RJF,RJG)
03900	C   3,POS.,STF,NT# OR CLEF,ITEM#,SIZEX,SIZEY, JH=-1 TO FILL ON CRT
03950	C			JH=-2 OMITS FILLER DURING PLOT
04000	
04100		N=0
04200		JD=MCLEF(L)+L
04300		IF(MCLEF(JD).EQ.999)N=JD+1
04600	1	IF(N.NE.0.AND.JH.NE.-2.AND.(PLT.OR.JH))CALL FILLER(MCLEF(N),
04650		1 RJB,CENTR,RJF,RJG)
04700	C  FILLS ONLY WHEN PLOTING OR RJG=-1
04800		END
04900	
05000		SUBROUTINE JDRAW(M,RJB,CENTR,RSTJC,RX,RY)
05100		COMMON/LL/LL
05200		DIMENSION M(1)
05300		RC=RX*RSTJC
05400		RD=RY*RSTJC
05600		DO 2 K=2,M(1)
05700		CALL UNPACK(IA,IB,M(K))
05800	CC	RA=IA*RC+RJB
05900	CC	RB=IB*RD+CENTR
06000	CC	IF(K.EQ.I)LL=3
06100	CC2	CALL LINES(RA,RB,LL)
06150	2	CALL LINES(FLOAT(IA)*RC+RJB,FLOAT(IB)*RD+CENTR,LL)
06200		END
06300	
06400		SUBROUTINE CENTER(CNTR)
06450	C  TO CENTER ITEMS CREATED WITH DRAWING PROG.
06800		COMMON /STF/RSTFAC(8),RSTJC
06900		COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
07100		COMMON/POSI/STF(8),JJB,POS
07300		EQUIVALENCE (RJD,RJQ(2))
07600		CNTR=POS+2+AMOD(RJD,100.)*RSTJC*7
07800		END